home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Source Code / Peter Lewis / PNL Libraries / MyProgress.p < prev    next >
Encoding:
Text File  |  1994-04-07  |  3.0 KB  |  138 lines  |  [TEXT/PJMM]
  1. unit MyProgress;
  2.  
  3. interface
  4.  
  5.     procedure PaintBarberPoll (r: rect; offset: integer);
  6.     procedure PaintProgress (r: rect; done, total: longInt);
  7.  
  8. implementation
  9.  
  10.     uses
  11.         FixMath;
  12.  
  13.     const
  14.         HiliteRGBP = $DA0;
  15.  
  16.     type
  17.         RGBColorPtr = ^RGBColor;
  18.  
  19.     procedure PaintProgress (r: rect; done, total: longInt);
  20.         var
  21.             it: integer;
  22.             ih: handle;
  23.             w, uw: integer;
  24.             oldfore: RGBColor;
  25.             has_colorQD: boolean;
  26.             sysEnv: SysEnvRec;
  27.     begin
  28.         FrameRect(r);
  29.         InsetRect(r, 1, 1);
  30.         with r do begin
  31.             w := right - left;
  32.             if total <= 0 then begin
  33.                 uw := 0;
  34.             end
  35.             else if done >= total then begin
  36.                 uw := w;
  37.             end
  38.             else begin
  39.                 uw := FracMul(w, FracDiv(done, total));
  40.             end;
  41.             right := left + uw;
  42.             has_colorqd := (SysEnvirons(1, sysEnv) = noErr) & sysenv.hasColorQD; { Gestalt has a bug that causes hasColourQD to always be set }
  43.             if has_colorQD then begin
  44.                 GetForeColor(oldfore);
  45.                 RGBForeColor(RGBColorPtr(HiliteRGBP)^);
  46.                 PaintRect(r);
  47.                 RGBForeColor(oldfore);
  48.             end
  49.             else
  50.                 FillRect(r, gray);
  51.             left := right;
  52.             right := right + w - uw;
  53.             EraseRect(r);
  54.         end;
  55.     end;
  56.  
  57.     procedure OffsetPtr (var p: univ Ptr; offset: longint);
  58.     inline
  59.         $201F,    (* move.l    (sp)+,d0    ; pop offset *)
  60.         $205F,    (* move.l    (sp)+,a0    ; pop address of p *)
  61.         $D190;    (* add.l    d0,(a0)        ; add offset to p *)
  62.  
  63.     type
  64.         MyPicture = record
  65.                 size: integer;
  66.                 r1: rect;
  67.                 data1: array[1..17] of integer;
  68.                 r2: rect;
  69.                 nintyeight: integer;
  70.                 rowbytes: integer;
  71.                 r3: rect;
  72.                 data2: array[1..34] of integer;
  73.                 r4: rect;
  74.                 r5: rect;
  75.                 mode: integer;
  76.                 eor: integer;
  77.             end;
  78.         MyPicturePtr = ^MyPicture;
  79.         MyPictureHandle = ^MyPicturePtr;
  80.  
  81.     procedure PaintBarberPoll (r: rect; offset: integer);
  82.         var
  83.             ph: MyPictureHandle;
  84.             rb: integer;
  85.             ts: integer;
  86.             p: ^integer;
  87.             i, j: integer;
  88.             b1, b2: integer;
  89.             o: integer;
  90.     begin
  91.         FrameRect(r);
  92.         InsetRect(r, 1, 1);
  93.         rb := (2 * (r.right - r.left) + 15) div 16 * 2;
  94.         ts := SizeOf(MyPicture) + (r.bottom - r.top) * (rb + 2);
  95.         ph := MyPictureHandle(NewHandle(ts));
  96.         HLock(handle(ph));
  97.         with ph^^ do begin
  98.             size := ts;
  99.             r1 := r;
  100.             r2 := r;
  101.             r3 := r;
  102.             r4 := r;
  103.             r5 := r;
  104.             nintyeight := $0098;
  105.             rowbytes := BOR(rb, $8000);
  106.             mode := 0;
  107.             StuffHex(@data1, '001102FF0C00FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0001000A');
  108.             StuffHex(@data2, '0000000000000000004800000048000000000002000100020000000000000000000000000000000000000002000000000000000000014444444444440002CCCCCCCCFFFF');
  109.             p := @eor;
  110.             for i := r.top to r.bottom - 1 do begin
  111.                 p^ := BOR(BSL(rb + 1, 8), rb - 1);
  112.                 OffsetPtr(p, 2);
  113.                 o := BAND((offset + i) * 2, 31);
  114.                 if o < 16 then begin
  115.                     b1 := BSR($5555AAAA, o);
  116.                     b2 := BSR($AAAA5555, o);
  117.                 end
  118.                 else begin
  119.                     b1 := BSR($AAAA5555, o - 16);
  120.                     b2 := BSR($5555AAAA, o - 16);
  121.                 end;
  122.                 for j := 1 to rb div 2 do begin
  123.                     if odd(j) then begin
  124.                         p^ := b1;
  125.                     end
  126.                     else begin
  127.                         p^ := b2;
  128.                     end;
  129.                     OffsetPtr(p, 2);
  130.                 end;
  131.             end;
  132.             p^ := $00FF; {end of record}
  133.         end;
  134.         DrawPicture(PicHandle(ph), r);
  135.         DisposeHandle(handle(ph));
  136.     end;
  137.  
  138. end.